home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / mac_ext.scm < prev   
Encoding:
Text File  |  1994-07-26  |  20.5 KB  |  576 lines  |  [TEXT/gamI]
  1. (##declare
  2.   (multilisp)
  3.   (extended-bindings)
  4.   (not safe)
  5.   (not autotouch)
  6.   (block)
  7.   (fixnum)
  8.   (not intr-checks))
  9.  
  10. ;------------------------------------------------------------------------------
  11.  
  12. ; Utilities
  13.  
  14. (define (mac#unsigned16->signed16 x) ; ##vector16-ref returns 0..65535
  15.   (##fixnum.- (##fixnum.modulo (##fixnum.+ x 32768) 65536) 32768))
  16.  
  17. ; Macintosh events
  18.  
  19. (define (mac#event-what ev)
  20.   (##vector16-ref ev 0))
  21. (define (mac#event-message ev)
  22.   (##fixnum.+ (##fixnum.* (##vector16-ref ev 1) 65536) (##vector16-ref ev 2)))
  23. (define (mac#event-when ev)
  24.   (##fixnum.+ (##fixnum.* (##vector16-ref ev 3) 65536) (##vector16-ref ev 4)))
  25. (define (mac#event-where ev)
  26.   (mac#point (##vector16-ref ev 5) (##vector16-ref ev 6)))
  27. (define (mac#event-modifiers ev)
  28.   (##vector16-ref ev 7))
  29.  
  30. (define (mac#modifiers-button? modifiers)
  31.   (##fixnum.zero? (##fixnum.logand modifiers 128)))
  32.  
  33. (define (mac#modifiers-command? modifiers)
  34.   (##not (##fixnum.zero? (##fixnum.logand modifiers 256))))
  35.  
  36. (define (mac#modifiers-shift? modifiers)
  37.   (##not (##fixnum.zero? (##fixnum.logand modifiers 512))))
  38.  
  39. (define (mac#modifiers-alphalock? modifiers)
  40.   (##not (##fixnum.zero? (##fixnum.logand modifiers 1024))))
  41.  
  42. (define (mac#modifiers-option? modifiers)
  43.   (##not (##fixnum.zero? (##fixnum.logand modifiers 2048))))
  44.  
  45. ; Quickdraw points
  46.  
  47. (define (mac#point v h)
  48.   (let ((p (##make-vector16 2 0)))
  49.     (##vector16-set! p 0 v)
  50.     (##vector16-set! p 1 h)
  51.     p))
  52.  
  53. (define (mac#point-v r) (mac#unsigned16->signed16 (##vector16-ref r 0)))
  54. (define (mac#point-h r) (mac#unsigned16->signed16 (##vector16-ref r 1)))
  55. (define (mac#point-v-set! r x) (##vector16-set! r 0 x))
  56. (define (mac#point-h-set! r x) (##vector16-set! r 1 x))
  57.  
  58. ; Quickdraw rectangles
  59.  
  60. (define (mac#rect top left bottom right)
  61.   (let ((r (##make-vector16 4 0)))
  62.     (##vector16-set! r 0 top)
  63.     (##vector16-set! r 1 left)
  64.     (##vector16-set! r 2 bottom)
  65.     (##vector16-set! r 3 right)
  66.     r))
  67.  
  68. (define (mac#rect-top r)    (mac#unsigned16->signed16 (##vector16-ref r 0)))
  69. (define (mac#rect-left r)   (mac#unsigned16->signed16 (##vector16-ref r 1)))
  70. (define (mac#rect-bottom r) (mac#unsigned16->signed16 (##vector16-ref r 2)))
  71. (define (mac#rect-right r)  (mac#unsigned16->signed16 (##vector16-ref r 3)))
  72. (define (mac#rect-top-set! r x)    (##vector16-set! r 0 x))
  73. (define (mac#rect-left-set! r x)   (##vector16-set! r 1 x))
  74. (define (mac#rect-bottom-set! r x) (##vector16-set! r 2 x))
  75. (define (mac#rect-right-set! r x)  (##vector16-set! r 3 x))
  76.  
  77. ; Quickdraw procedures
  78.  
  79. (define (mac#newwindow bounds title visible procid behind goaway)
  80.   (mac_#newwindow bounds title visible procid behind goaway))
  81.  
  82. (define (mac#getnewwindow windowid behind)
  83.   (mac_#getnewwindow windowid behind))
  84.  
  85. (define (mac#disposewindow w)
  86.   (mac_#disposewindow w))
  87.  
  88. (define (mac#selectwindow w)
  89.   (mac_#selectwindow w))
  90.  
  91. (define (mac#hidewindow w)
  92.   (mac_#hidewindow w))
  93.  
  94. (define (mac#showwindow w)
  95.   (mac_#showwindow w))
  96.  
  97. (define (mac#frontwindow)
  98.   (mac_#frontwindow))
  99.  
  100. (define (mac#findwindow pt w-cell)
  101.   (mac_#findwindow pt w-cell))
  102.  
  103. (define (mac#trackgoaway w pt)
  104.   (mac_#trackgoaway w pt))
  105.  
  106. (define (mac#dragwindow w pt r)
  107.   (mac_#dragwindow w pt r))
  108.  
  109. (define (mac#invalrect port r)
  110.   (mac_#invalrect port r))
  111.  
  112. (define (mac#beginupdate w)
  113.   (mac_#beginupdate w))
  114.  
  115. (define (mac#endupdate w)
  116.   (mac_#endupdate w))
  117.  
  118. (define (mac#openport port) (mac_#openport port))
  119. (define (mac#initport port) (mac_#initport port))
  120. (define (mac#closeport port) (mac_#closeport port))
  121. (define (mac#setport port) (mac_#setport port))
  122. (define (mac#getport) (mac_#getport))
  123. (define (mac#setorigin port h v) (mac_#setport port h v))
  124. (define (mac#backpat port pat) (mac_#backpat port pat))
  125. (define (mac#hidecursor) (mac_#hidecursor))
  126. (define (mac#showcursor) (mac_#showcursor))
  127. (define (mac#pensize port width height) (mac_#pensize port width height))
  128. (define (mac#penmode port mode) (mac_#penmode port mode))
  129. (define (mac#penpat port pat) (mac_#penpat port pat))
  130. (define (mac#pennormal port) (mac_#pennormal port))
  131. (define (mac#moveto port h v) (mac_#moveto port h v))
  132. (define (mac#move port dh dv) (mac_#move port dh dv))
  133. (define (mac#lineto port h v) (mac_#lineto port h v))
  134. (define (mac#line port dh dv) (mac_#line port dh dv))
  135. (define (mac#textfont port font) (mac_#textfont port font))
  136. (define (mac#textface port face) (mac_#textface port face))
  137. (define (mac#textmode port mode) (mac_#textmode port mode))
  138. (define (mac#textsize port size) (mac_#textsize port size))
  139. (define (mac#spaceextra port extra) (mac_#spaceextra port extra))
  140. (define (mac#drawchar port ch) (mac_#drawchar port ch))
  141. (define (mac#drawstring port s) (mac_#drawstring port s))
  142. (define (mac#drawtext port textbuf firstbyte bytecount)
  143.   (mac_#drawtext port textbuf firstbyte bytecount))
  144. (define (mac#charwidth port ch) (mac_#charwidth port ch))
  145. (define (mac#stringwidth port s) (mac_#stringwidth port s))
  146. (define (mac#textwidth port textbuf firstbyte bytecount)
  147.   (mac_#textwidth port textbuf firstbyte bytecount))
  148. (define (mac#localtoglobal port pt) (mac_#localtoglobal port pt))
  149. (define (mac#globaltolocal port pt) (mac_#globaltolocal port pt))
  150. (define (mac#framerect port r) (mac_#framerect port r))
  151. (define (mac#paintrect port r) (mac_#paintrect port r))
  152. (define (mac#eraserect port r) (mac_#eraserect port r))
  153. (define (mac#invertrect port r) (mac_#invertrect port r))
  154. (define (mac#fillrect port r pat) (mac_#fillrect port r pat))
  155. (define (mac#frameroundrect port r ovwd ovht)
  156.   (mac_#frameroundrect port r ovwd ovht))
  157. (define (mac#paintroundrect port r ovwd ovht)
  158.   (mac_#paintroundrect port r ovwd ovht))
  159. (define (mac#eraseroundrect port r ovwd ovht)
  160.   (mac_#eraseroundrect port r ovwd ovht))
  161. (define (mac#invertroundrect port r ovwd ovht)
  162.   (mac_#invertroundrect port r ovwd ovht))
  163. (define (mac#fillroundrect port r ovwd ovht pat)
  164.   (mac_#fillroundrect port r ovwd ovht pat))
  165. (define (mac#frameoval port r) (mac_#frameoval port r))
  166. (define (mac#paintoval port r) (mac_#paintoval port r))
  167. (define (mac#eraseoval port r) (mac_#eraseoval port r))
  168. (define (mac#invertoval port r) (mac_#invertoval port r))
  169. (define (mac#filloval port r pat) (mac_#filloval port r pat))
  170. (define (mac#framearc port r startangle arcangle)
  171.   (mac_#framearc port r startangle arcangle))
  172. (define (mac#paintarc port r startangle arcangle)
  173.   (mac_#paintarc port r startangle arcangle))
  174. (define (mac#erasearc port r startangle arcangle)
  175.   (mac_#erasearc port r startangle arcangle))
  176. (define (mac#invertarc port r startangle arcangle)
  177.   (mac_#invertarc port r startangle arcangle))
  178. (define (mac#fillarc port r startangle arcangle pat)
  179.   (mac_#fillarc port r startangle arcangle pat))
  180.  
  181. ; Menus
  182.  
  183. (define (mac#menuselection selection) #f)
  184.  
  185. (define (mac#newmenu menuid str) (mac_#newmenu menuid str))
  186. (define (mac#getmenu resourceid) (mac_#getmenu resourceid))
  187. (define (mac#disposemenu themenu) (mac_#disposemenu themenu))
  188. (define (mac#appendmenu themenu str) (mac_#appendmenu themenu str))
  189. (define (mac#addresmenu themenu thetype) (mac_#addresmenu themenu thetype))
  190. (define (mac#insertresmenu themenu thetype afteritem)
  191.   (mac_#insertresmenu themenu thetype afteritem))
  192. (define (mac#insertmenu themenu beforeid) (mac_#insertmenu themenu beforeid))
  193. (define (mac#drawmenubar) (mac_#drawmenubar))
  194. (define (mac#deletemenu menuid) (mac_#deletemenu menuid))
  195. (define (mac#clearmenubar) (mac_#clearmenubar))
  196. (define (mac#getnewmbar menubarid) (mac_#getnewmbar menubarid))
  197. (define (mac#getmenubar) (mac_#getmenubar))
  198. (define (mac#setmenubar menulist) (mac_#setmenubar menulist))
  199. (define (mac#menuselect p) (mac_#menuselect p))
  200. (define (mac#menukey ch) (mac_#menukey ch))
  201. (define (mac#hilitemenu menuid) (mac_#hilitemenu menuid))
  202. (define (mac#disableitem themenu item) (mac_#disableitem themenu item))
  203. (define (mac#enableitem themenu item) (mac_#enableitem themenu item))
  204. (define (mac#getmhandle menuid) (mac_#getmhandle menuid))
  205.  
  206. ; Standard file get/put
  207.  
  208. (define (mac#sfgetfile (prompt "") (ftypes "TEXT"))
  209.   (mac_#sfgetfile (##make-string 256 #\space) prompt ftypes))
  210.  
  211. (define (mac#sfputfile (prompt "") (default ""))
  212.   (mac_#sfputfile (##make-string 256 #\space) prompt default))
  213.  
  214. ; Other procedures
  215.  
  216. (define (mac#getmouse pt) (mac_#getmouse pt))
  217. (define (mac#button) (mac_#button))
  218. (define (mac#tickcount) (mac_#tickcount))
  219. (define (mac#delay duration) (mac_#delay duration))
  220. (define (mac#sysbeep duration) (mac_#sysbeep duration))
  221. (define (mac#seteventmask themask) (mac_#seteventmask themask))
  222.  
  223. (define (mac#peek8 ptr) (mac_#peek8 ptr))
  224. (define (mac#poke8 ptr val) (mac_#poke8 ptr val))
  225. (define (mac#peek16 ptr) (mac_#peek16 ptr))
  226. (define (mac#poke16 ptr val) (mac_#poke16 ptr val))
  227. (define (mac#peek32 ptr) (mac_#peek32 ptr))
  228. (define (mac#poke32 ptr val) (mac_#poke32 ptr val))
  229.  
  230. ; Editor windows
  231.  
  232. (define (mac#edit filename (line 0) (char 0))
  233.   (mac_#edit filename line char))
  234.  
  235. ; Text windows
  236.  
  237. (define (open-text-window name)
  238.   (if (##string? name)
  239.     (##open-input-output-file
  240.       (##string-append (##make-string 1 (##integer->char 2)) name))
  241.     #f))
  242.  
  243. ; Online help
  244.  
  245. (define (mac#help name)
  246.   (mac_#help name))
  247.  
  248. (define (help (name ""))
  249.   (cond ((##string? name) (mac#help name))
  250.         ((##symbol? name) (mac#help (##symbol->string name)))
  251.         (else             (mac#help ""))))
  252.  
  253. ;------------------------------------------------------------------------------
  254.  
  255. ; Window manager
  256.  
  257. (define mac#window-bindings (##cons #f '()))
  258.  
  259. (define mac#window-drag-bounds (mac#rect 0 0 32000 32000))
  260.  
  261. (define (mac#window-bind w wind)
  262.   (let ((wind-struct (##cons wind (##cons #f (##make-queue)))))
  263.     (let loop ((prev mac#window-bindings) (pres (##cdr mac#window-bindings)))
  264.       (if (##pair? pres)
  265.         (let ((x (##car pres)))
  266.           (if (##fixnum.= (##car x) w)
  267.             (##set-cdr! x wind-struct)
  268.            (loop pres (##cdr pres))))
  269.         (##set-cdr! prev (##cons (##cons w wind-struct) '()))))))
  270.  
  271. (define (mac#window-unbind w)
  272.   (let loop ((prev mac#window-bindings) (pres (##cdr mac#window-bindings)))
  273.     (if (##pair? pres)
  274.       (let ((x (##car pres)))
  275.         (if (##fixnum.= (##car x) w)
  276.           (##set-cdr! prev (##cdr pres))
  277.           (loop pres (##cdr pres))))
  278.       #f)))
  279.  
  280. (define (mac#window-lookup w)
  281.   (let loop ((prev mac#window-bindings) (pres (##cdr mac#window-bindings)))
  282.     (if (##pair? pres)
  283.       (let ((x (##car pres)))
  284.         (if (##fixnum.= (##car x) w)
  285.           (##cdr x)
  286.           (loop pres (##cdr pres))))
  287.       #f)))
  288.  
  289. (define (mac#window-reset w)
  290.   (let ((wind-struct (mac#window-lookup w)))
  291.     (if wind-struct
  292.       (##set-cdr! wind-struct (##cons #f (##make-queue))))
  293.     #f))
  294.  
  295. (define (mac#window-handle-event wind-struct event)
  296.  
  297.   (define (send-window-event wind event)
  298.     (let ((what (mac#event-what event)))
  299.       (cond ((##fixnum.= what 0)
  300.              ((wind 'GOAWAY)))
  301.             ((or (##fixnum.= what 1)
  302.                  (##fixnum.= what 2))
  303.              ((wind (cond ((##fixnum.= what 1) 'MOUSEDOWN)
  304.                           (else                'MOUSEUP)))
  305.               (mac#event-where event)
  306.               (mac#event-modifiers event)))
  307.             ((or (##fixnum.= what 3)
  308.                  (##fixnum.= what 4)
  309.                  (##fixnum.= what 5))
  310.              ((wind (cond ((##fixnum.= what 3) 'KEYDOWN)
  311.                           ((##fixnum.= what 4) 'KEYUP)
  312.                           (else                'AUTOKEY)))
  313.               (##type-cast (##fixnum.logand (mac#event-message event) 255) 7)
  314.               (mac#event-modifiers event)))
  315.             ((##fixnum.= what 6)
  316.              ((wind 'UPDATE)))
  317.             ((##fixnum.= what 8)
  318.              (if (##fixnum.odd? (mac#event-modifiers event))
  319.                ((wind 'ACTIVATE))
  320.                ((wind 'DEACTIVATE)))))))
  321.  
  322.   (let* ((wind (##car wind-struct))
  323.          (sequentializer (##cdr wind-struct))
  324.          (pending-events (##cdr sequentializer)))
  325.     (if (##car sequentializer)
  326.  
  327.       (##queue-put! pending-events event) ; queue event on window
  328.  
  329.       (begin
  330.         (##set-car! sequentializer #t)
  331.         (future ; spawn a task to handle the window's events
  332.           (let loop ((event event))
  333.             (send-window-event wind event)
  334.             (let ((x (##queue-get! pending-events)))
  335.               (if x
  336.                 (loop (##car x))
  337.                 (##set-car! sequentializer #f))))))))
  338.  
  339.   #f)
  340.  
  341. (define (mac#event-handler event)
  342.  
  343.   ; IMPORTANT NOTE:
  344.   ;
  345.   ; Event handling must be done atomically to preserve the ordering
  346.   ; of the events.  Events are generated and handled in bursts every time
  347.   ; there is a timer interrupt (roughly 10 times a second).  If interrupts
  348.   ; were enabled and the handling of an event took too long (> 1/10 sec),
  349.   ; for example if a garbage collection occurs in the middle of processing
  350.   ; or there is a user interrupt, then it would be possible for the handling
  351.   ; of a later event to start and complete before the processing of the
  352.   ; original event is finished.
  353.   ;
  354.   ; To solve this problem, this procedure is written so that it
  355.   ; does not cons and does not allow interrupts (interrupt checks are
  356.   ; not generated inside the procedure and no procedure which might check
  357.   ; interrupts is called).  To prevent consing this procedure mutates
  358.   ; constants (this is OK in Gambit even though it is an error in IEEE-Scheme).
  359.   ;
  360.   ; In addition, each window has an associated queue of pending events.
  361.   ; Only one event per window can be processed at a time.  If an event is
  362.   ; generated for a particular window and that window is still processing a
  363.   ; previous event, the event is put on the window's queue.  When the
  364.   ; processing of an event ends, the next event on the queue is processed (if
  365.   ; there is one).  Unfortunately, this means that if the processing of an
  366.   ; event is aborted (due to an error or user interrupt), the window will
  367.   ; not accept any new events.  The procedure call (mac#window-reset wind)
  368.   ; can be used to reenable the processing of new events on the window 'wind'.
  369.   ;
  370.   ; The processing of a window's events is done in a task (created by a
  371.   ; future).  This means that multiple windows may be "running" concurrently
  372.   ; with the main program.  This introduces the usual multitasking problems.
  373.   ; Shared data structures should be protected with semaphores to guarantee
  374.   ; that only one task is accessing them at any given point in time.
  375.  
  376.   (let* ((what (##vector16-ref event 0))
  377.          (message (##fixnum.+ (##fixnum.* (##vector16-ref event 1) 65536)
  378.                               (##vector16-ref event 2)))
  379.          (w-cell '(0)) ; these two constants get mutated (to avoid consing)
  380.          (where "1234"))
  381.     (cond ((or (##fixnum.= what 1)  ; mousedown event
  382.                (##fixnum.= what 2)) ; mouseup event
  383.            (##vector16-set! where 0 (##vector16-ref event 5)) ; mutate 'where'
  384.            (##vector16-set! where 1 (##vector16-ref event 6))
  385.            (let* ((in (mac#findwindow where w-cell)) ; mutate 'w-cell'
  386.                   (w (##car w-cell))
  387.                   (wind-struct (mac#window-lookup w)))
  388.              (if wind-struct
  389.                (cond ((##fixnum.= in 3) ; incontent
  390.                       (if (##fixnum.= w (mac#frontwindow))
  391.                         (begin
  392.                           (mac#globaltolocal w where)
  393.                           (##vector16-set! event 5 (##vector16-ref where 0))
  394.                           (##vector16-set! event 6 (##vector16-ref where 1))
  395.                           (mac#window-handle-event wind-struct event))
  396.                         (begin
  397.                           (if (##fixnum.= what 1) (mac#selectwindow w))
  398.                           #f)))
  399.                      ((##fixnum.= in 4) ; indrag
  400.                       (if (##fixnum.= what 1)
  401.                         (mac#dragwindow w where mac#window-drag-bounds))
  402.                       #f)
  403.                      ((##fixnum.= in 6) ; ingoaway
  404.                       (if (and (##fixnum.= what 1) (mac#trackgoaway w where))
  405.                         (begin
  406.                           (##vector16-set! event 0 0)
  407.                           (mac#window-handle-event wind-struct event))
  408.                         #f)))
  409.                (##os-handle-event event))))
  410.           ((or (##fixnum.= what 3)  ; keydown event
  411.                (##fixnum.= what 4)  ; keyup event
  412.                (##fixnum.= what 5)) ; autokey event
  413.            (if (mac#modifiers-command? (##vector16-ref event 7)) ; command?
  414.              (##os-handle-event event)
  415.              (let* ((w (mac#frontwindow))
  416.                     (wind-struct (mac#window-lookup w)))
  417.                (if wind-struct
  418.                  (mac#window-handle-event wind-struct event)
  419.                  (##os-handle-event event)))))
  420.           ((##fixnum.= what 6) ; update event
  421.            (let ((wind-struct (mac#window-lookup message)))
  422.              (if wind-struct
  423.                (begin
  424.                  (mac#beginupdate message) ; discard update region
  425.                  (mac#endupdate message)
  426.                  (mac#window-handle-event wind-struct event))
  427.                (##os-handle-event event))))
  428.           ((##fixnum.= what 8) ; activate and deactivate events
  429.            (let ((wind-struct (mac#window-lookup message)))
  430.              (if wind-struct
  431.                (mac#window-handle-event wind-struct event)
  432.                (##os-handle-event event))))
  433.           (else
  434.            (##os-handle-event event)))))
  435.  
  436. (set! ##handle-os-event mac#event-handler)
  437.  
  438. ;------------------------------------------------------------------------------
  439.  
  440. ; Drawing window
  441.  
  442. (define clear-graphics #f)
  443. (define position-pen #f)
  444. (define draw-line-to #f)
  445. (define draw-point #f)
  446. (define clear-point #f)
  447. (define graphics-text #f)
  448.  
  449. (let ()
  450.  
  451.   (define top     40)
  452.   (define right   510)
  453.   (define y-max   200.) ; must be inexact (flonum)
  454.   (define x-max   200.) ;   "        "
  455.   (define scaling .5)   ;   "        "
  456.   (define visible? #f)
  457.  
  458.   (define (cx x)
  459.     (##flonum.->fixnum
  460.       (##flonum.* (##flonum.+ x-max (##real-part (##exact->inexact x)))
  461.                   scaling)))
  462.  
  463.   (define (cy y)
  464.     (##flonum.->fixnum
  465.       (##flonum.* (##flonum.- y-max (##real-part (##exact->inexact y)))
  466.                   scaling)))
  467.  
  468.   (let* ((clear-rect (mac#rect -32000 -32000 32000 32000))
  469.          (width (##flonum.->fixnum (##flonum.* (##flonum.* 2. x-max) scaling)))
  470.          (height (##flonum.->fixnum (##flonum.* (##flonum.* 2. y-max) scaling)))
  471.          (w (mac#newwindow
  472.               (mac#rect top (##fixnum.- right width) (##fixnum.+ top height) right)
  473.               "Drawing" visible? 19 (if visible? -1 0) #t))
  474.          (head (##cons #f '()))
  475.          (tail head)
  476.          (pen-x0 (cx 0))
  477.          (pen-y0 (cy 0))
  478.          (pen-x #f)
  479.          (pen-y #f))
  480.  
  481.     (define (wind msg)
  482.       (cond ((##eq? msg 'GOAWAY) goaway)
  483.             ((##eq? msg 'UPDATE) update)
  484.             (else                ##list))) ; discard other events
  485.  
  486.     (define (goaway)
  487.       (mac#hidewindow w))
  488.  
  489.     (define (update)
  490.       (set! pen-x pen-x0)
  491.       (set! pen-y pen-y0)
  492.       (let loop ((l (##cdr head)))
  493.         (if (##pair? l)
  494.           (begin ((##car l)) (loop (##cdr l))))))
  495.  
  496.     (define (show)
  497.       (if (##fixnum.zero? (mac#peek8 (##fixnum.+ w 110))) ; not visible?
  498.         (begin
  499.           (mac#showwindow w)      ; make it visible
  500.           (mac#selectwindow w)))) ; and in front of all other windows
  501.  
  502.     (define (clear)
  503.       (##set-cdr! head '())
  504.       (set! tail head)
  505.       (mac#eraserect w clear-rect))
  506.  
  507.     (define (add action)
  508.       (let ((x (##cons action '())))
  509.         (##set-cdr! tail x)
  510.         (set! tail x)
  511.         (show)
  512.         (action)))
  513.  
  514.     (define (init)
  515.       (set! pen-x pen-x0)
  516.       (set! pen-y pen-y0)
  517.       (clear))
  518.  
  519.     (define (make-position-pen x y)
  520.       (lambda ()
  521.         (set! pen-x x)
  522.         (set! pen-y y)))
  523.  
  524.     (define (make-draw-line-to x y)
  525.       (lambda ()
  526.         (mac#moveto w pen-x pen-y)
  527.         (mac#lineto w x y)
  528.         (set! pen-x x)
  529.         (set! pen-y y)))
  530.  
  531.     (define (make-draw-point x y)
  532.       (lambda ()
  533.         (mac#moveto w x y)
  534.         (mac#lineto w x y)))
  535.  
  536.     (define (make-clear-point x y)
  537.       (lambda ()
  538.         (mac#penmode w 11) ; patBic
  539.         (mac#moveto w x y)
  540.         (mac#lineto w x y)
  541.         (mac#penmode w 8))) ; patCopy
  542.  
  543.     (define (make-graphics-text text x y)
  544.       (lambda ()
  545.         (mac#moveto w x y)
  546.         (mac#drawstring w text)))
  547.  
  548.     (set! clear-graphics
  549.       (lambda () (show) (clear) #f))
  550.  
  551.     (set! position-pen
  552.       (lambda (x y) (add (make-position-pen (cx x) (cy y))) #f))
  553.  
  554.     (set! draw-line-to
  555.       (lambda (x y) (add (make-draw-line-to (cx x) (cy y))) #f))
  556.  
  557.     (set! draw-point
  558.       (lambda (x y) (add (make-draw-point (cx x) (cy y))) #f))
  559.  
  560.     (set! clear-point
  561.       (lambda (x y) (add (make-clear-point (cx x) (cy y))) #f))
  562.  
  563.     (set! graphics-text
  564.       (lambda (text x y)
  565.         (if (##string? text) (add (make-graphics-text text (cx x) (cy y))))
  566.         #f))
  567.  
  568.     (mac#textfont w 4) ; monaco
  569.     (mac#textsize w 9)
  570.  
  571.     (init)
  572.  
  573.     (mac#window-bind w wind)))
  574.  
  575. ;------------------------------------------------------------------------------
  576.